home *** CD-ROM | disk | FTP | other *** search
/ Games of Daze / Infomagic - Games of Daze (Summer 1995) (Disc 1 of 2).iso / x2ftp / msdos / docs / winer / typisort.bas < prev    next >
BASIC Source File  |  1992-05-13  |  5KB  |  146 lines
  1. '********** TYPISORT.BAS - performs an indexed multi-key sort on TYPE arrays
  2.  
  3. 'Copyright (c) 1992 Ethan Winer
  4.  
  5. DEFINT A-Z
  6.  
  7. DECLARE FUNCTION Compare3% (BYVAL Seg1, BYVAL Adr1, BYVAL Seg2, BYVAL Adr2, NumBytes)
  8. DECLARE SUB SwapMem (BYVAL Seg1, BYVAL Adr1, BYVAL Seg2, BYVAL Adr2, BYVAL Length)
  9. DECLARE SUB TypeISort (Segment, Address, ElSize, Offset, KeySize, NumEls, Index())
  10.  
  11. CONST NumEls% = 23              'this fits on the screen
  12.  
  13. TYPE MyType
  14.   LastName  AS STRING * 10
  15.   FirstName AS STRING * 10
  16.   Dollars   AS STRING * 6
  17.   Cents     AS STRING * 2
  18. END TYPE
  19. REDIM Array(1 TO NumEls%) AS MyType
  20. REDIM Index(1 TO NumEls%)   'create the index array
  21.  
  22. '---- Disable all but one of the following blocks to test
  23.  
  24. Offset = 27                 'start sorting with Cents
  25. ElSize = LEN(Array(1))      'the length of each element
  26. KeySize = 2                 'sort on the Cents only
  27.  
  28. Offset = 21                 'start sorting with Dollars
  29. ElSize = LEN(Array(1))      'the length of each element
  30. KeySize = 8                 'sort Dollars and Cents only
  31.  
  32. Offset = 11                 'start sorting with FirstName
  33. ElSize = LEN(Array(1))      'the length of each element
  34. KeySize = 18                'sort FirstName through Cents
  35.  
  36. Offset = 1                  'start sorting with LastName
  37. ElSize = LEN(Array(1))      'the length of each element
  38. KeySize = ElSize            'sort based on all 4 fields
  39.  
  40. FOR X = 1 TO NumEls%        'build the array from DATA
  41.   READ Array(X).LastName
  42.   READ Array(X).FirstName
  43.   READ Amount$              'format the amount into money
  44.   Dot = INSTR(Amount$, ".")
  45.   IF Dot THEN
  46.     RSET Array(X).Dollars = LEFT$(Amount$, Dot - 1)
  47.     Array(X).Cents = LEFT$(MID$(Amount$, Dot + 1) + "00", 2)
  48.   ELSE
  49.     RSET Array(X).Dollars = Amount$
  50.     Array(X).Cents = "00"
  51.   END IF
  52. NEXT
  53.  
  54. FOR X = 1 TO NumEls%            'initialize the index
  55.   Index(X) = X - 1              'but starting with 0
  56. NEXT
  57.  
  58. Segment = VARSEG(Array(1))      'show where the array is
  59. Address = VARPTR(Array(1))      '  located in memory
  60. CALL TypeISort(Segment, Address, ElSize, Offset, KeySize, NumEls%, Index())
  61.  
  62. CLS                             'display the results
  63. FOR X = 1 TO NumEls%            '+ 1 adjusts to one-based
  64.   PRINT Array(Index(X) + 1).LastName,
  65.   PRINT Array(Index(X) + 1).FirstName,
  66.   PRINT Array(Index(X) + 1).Dollars; ".";
  67.   PRINT Array(Index(X) + 1).Cents
  68. NEXT
  69.  
  70. DATA Smith, John, 123.45
  71. DATA Cramer, Phil, 11.51
  72. DATA Hogan, Edward, 296.08
  73. DATA Cramer, Phil, 112.01
  74. DATA Malin, Donald, 13.45
  75. DATA Cramer, Phil, 111.3
  76. DATA Smith, Ralph, 123.22
  77. DATA Smith, John, 112.01
  78. DATA Hogan, Edward, 8999.04
  79. DATA Hogan, Edward, 8999.05
  80. DATA Smith, Bob, 123.45
  81. DATA Cramer, Phil, 11.50
  82. DATA Hogan, Edward, 296.88
  83. DATA Malin, Donald, 13.01
  84. DATA Cramer, Phil, 111.1
  85. DATA Smith, Ralph, 123.07
  86. DATA Smith, John, 112.01
  87. DATA Hogan, Edward, 8999.33
  88. DATA Hogan, Edward, 8999.17
  89. DATA Hogan, Edward, 8999.24
  90. DATA Smith, John, 123.05
  91. DATA Cramer, David, 1908.80
  92. DATA Cramer, Phil, 112
  93.  
  94. SUB TypeISort (Segment, Address, ElSize, Displace, KeySize, NumEls, Index()) STATIC
  95.  
  96. REDIM QStack(NumEls \ 5 + 10)   'create a stack
  97.  
  98. First = 1                       'initialize working variables
  99. Last = NumEls
  100. Offset = Displace - 1           'make zero-based now for speed later
  101.  
  102. DO
  103.   DO
  104.     Temp = (Last + First) \ 2   'seek midpoint
  105.     I = First
  106.     J = Last
  107.  
  108.     DO          'change -1 to 1 and 1 to -1 below to sort descending
  109.       WHILE Compare3%(Segment, Address + Offset + (Index(I) * ElSize), Segment, Address + Offset + (Index(Temp) * ElSize), KeySize) = -1
  110.         I = I + 1
  111.       WEND
  112.       WHILE Compare3%(Segment, Address + Offset + (Index(J) * ElSize), Segment, Address + Offset + (Index(Temp) * ElSize), KeySize) = 1
  113.         J = J - 1
  114.       WEND
  115.       IF I > J THEN EXIT DO
  116.       IF I < J THEN
  117.         SWAP Index(I), Index(J)
  118.         IF Temp = I THEN
  119.           Temp = J
  120.         ELSEIF Temp = J THEN
  121.           Temp = I
  122.         END IF
  123.       END IF
  124.       I = I + 1
  125.       J = J - 1
  126.     LOOP WHILE I <= J
  127.  
  128.     IF I < Last THEN
  129.       QStack(StackPtr) = I             'Push I
  130.       QStack(StackPtr + 1) = Last      'Push Last
  131.       StackPtr = StackPtr + 2
  132.     END IF
  133.  
  134.     Last = J
  135.   LOOP WHILE First < Last
  136.  
  137.   IF StackPtr = 0 THEN EXIT DO          'Done
  138.   StackPtr = StackPtr - 2
  139.   First = QStack(StackPtr)              'Pop First
  140.   Last = QStack(StackPtr + 1)           'Pop Last
  141. LOOP
  142.  
  143. ERASE QStack                    'delete the stack array
  144.  
  145. END SUB
  146.